Case 1 Learning Objective 4

Author

Lisa Levoir and Jeffrey Zhuohui Liang

Published

August 29, 2023

1 Analyzing medical students scores

Background given in the case description: “The course lasts twelve weeks. Throughout the course, students are assessed in multiple ways, including weekly quizzes, slide exams, and essays. They also take an end of course exam that includes essay, short answer, and multiple-choice components. The final data has the average scores for those assessments. Students are required to take laboratory practical (gross anatomy, histology, pathology and neuroanatomy) exams which are averaged into the final grade. Students also take a National Board of Medical Examiners (NBME) standardized exam in each course. Theoretically, if they do well on these exams, they should do well in the course overall. All of the assessments have been calculated on a 100- point scale.”

1.1 Questions from Learning Objective 4

  • How should we define not pass/ marginal pass/ pass thresholds and criteria?
  • How do these thresholds compare to final exam scores?

1.2 Data

There are 92 students. 2 students scored below 70 on the final exam which is grounds for an immediate failing threshold. 3 students scored between a 70 & 80 on the final which could be considered students for further scrutiny.

Code
label(dt$quiz)      <- "Quiz score (mean weekly performance)"
label(dt$nbme)      <- "National Board of Medical Examiners score"
label(dt$ga)        <- "Gross anatomy (mean score)"
label(dt$slide)      <- "Slide exams score (mean)"
label(dt$part.c)      <- "Part C score"
label(dt$essay)      <- "Essay score (mean)"
label(dt$eob.exam)      <- "End of Block (course term) exam"
label(dt$final)      <- "Final score"

table1(~quiz + nbme + ga + slide + part.c + essay+ eob.exam + final , data=dt, topclass="Rtable1-zebra",)
Overall
(N=92)
Quiz score (mean weekly performance)
Mean (SD) 0.821 (0.0685)
Median [Min, Max] 0.820 [0.660, 1.00]
National Board of Medical Examiners score
Mean (SD) 89.9 (5.45)
Median [Min, Max] 91.0 [74.0, 100]
Gross anatomy (mean score)
Mean (SD) 83.0 (9.89)
Median [Min, Max] 83.9 [49.5, 100]
Slide exams score (mean)
Mean (SD) 82.3 (10.0)
Median [Min, Max] 83.9 [53.1, 100]
Part C score
Mean (SD) 81.1 (8.70)
Median [Min, Max] 81.6 [59.6, 100]
Essay score (mean)
Mean (SD) 86.8 (5.42)
Median [Min, Max] 87.3 [71.3, 95.8]
End of Block (course term) exam
Mean (SD) 84.9 (6.83)
Median [Min, Max] 85.0 [65.0, 99.0]
Final score
Mean (SD) 88.5 (5.63)
Median [Min, Max] 88.5 [68.0, 100]
Code
length(unique(dt$id))
[1] 92

Note: Part C score is “like a catch-all exam if the knowledge can’t be obtained through their lab and essay assessments.”

  • not included in our data (but included in the student evaluation) is the score for the laboratory practical which “has multiple assessment scores which are captured in the data such as the histology, pathology, etc. - which are not specifically named like that.”

    • We will disregard for our purposes

1.2.1 Scores based on startifying by passing the final exam at 70% threshold

Code
dt = dt %>% 
  mutate(quiz = 100*quiz)

tableby(pass~.,dt %>% 
          select(-id) %>% 
          mutate(pass = final>70),
        control = 
          tableby.control(
            numeric.stats = c("meansd","median","range"),
          )) %>% 
  summary() %>% 
  knitr::kable()
FALSE (N=2) TRUE (N=90) Total (N=92) p value
Quiz score (mean weekly performance) 0.011
   Mean (SD) 70.000 (1.881) 82.377 (6.679) 82.108 (6.853)
   Median 70.000 82.335 82.000
   Range 68.670 - 71.330 66.000 - 100.000 66.000 - 100.000
National Board of Medical Examiners score < 0.001
   Mean (SD) 76.000 (2.828) 90.178 (5.087) 89.870 (5.452)
   Median 76.000 91.000 91.000
   Range 74.000 - 78.000 78.000 - 100.000 74.000 - 100.000
Gross anatomy (mean score) 0.002
   Mean (SD) 61.735 (17.317) 83.446 (9.285) 82.974 (9.887)
   Median 61.735 84.439 83.929
   Range 49.490 - 73.980 51.531 - 100.000 49.490 - 100.000
Slide exams score (mean) 0.001
   Mean (SD) 60.455 (2.524) 82.736 (9.558) 82.252 (10.005)
   Median 60.455 84.180 83.925
   Range 58.670 - 62.240 53.060 - 100.000 53.060 - 100.000
Part C score < 0.001
   Mean (SD) 61.410 (2.517) 81.549 (8.271) 81.112 (8.700)
   Median 61.410 81.980 81.590
   Range 59.630 - 63.190 64.230 - 100.000 59.630 - 100.000
Essay score (mean) < 0.001
   Mean (SD) 73.625 (3.359) 87.059 (5.091) 86.767 (5.418)
   Median 73.625 87.250 87.250
   Range 71.250 - 76.000 71.250 - 95.750 71.250 - 95.750
End of Block (course term) exam < 0.001
   Mean (SD) 66.500 (2.121) 85.322 (6.317) 84.913 (6.833)
   Median 66.500 85.000 85.000
   Range 65.000 - 68.000 69.000 - 99.000 65.000 - 99.000
Final score < 0.001
   Mean (SD) 68.000 (0.000) 88.911 (4.773) 88.457 (5.628)
   Median 68.000 89.000 88.500
   Range 68.000 - 68.000 78.000 - 100.000 68.000 - 100.000

Below is a pairs plot where students are divided into groups depending on whether they passed or if they scored below 80% which we called “almost fail”. These students deserve more scrutiny - how did they perform on other assessments?

Code
set.seed(123123)
pc = prcomp(dt %>% select(-id,-final) %>% mutate_all(scale))

ggpairs(dt %>% select(-id),
        aes(color=ifelse(final>80,"pass","(almost)fail")),
        progress = F)

Code
cl = kmeans(dt %>% select(-id) %>% mutate_all(scale),
            centers = 4)$cluster
dt %>% left_join(tibble(id = dt$id,cluster = as.factor(cl))) %>% 
  cbind(pc$x) %>% 
  ggplot(aes(x=PC1,y=final,color=cluster)) +
  scale_color_calc()+
  geom_jitter()
Joining with `by = join_by(id)`

Code
autoplot(pc,color = as.factor(cl))
Warning in !(is.vector(value) && length(value) > 1L) && value %in% columns:
'length(x) = 92 > 1' in coercion to 'logical(1)'

1.3 Can I create a better metric?

Code
overall = 
  0.6*rowMeans(dt %>% select(-id,-final,-nbme)) +
  0.4*dt$nbme
dt %>% select(-id) %>% 
  mutate(overall = overall) %>% 
  ggpairs(.,
          aes(color = ifelse(
            overall> quantile(overall,0.05),
            "pass","fail")),
          progress = F)

Code
dt  %>% 
  mutate(overall = overall,
         pass = overall>quantile(overall,0.05)) %>% 
  cbind(pc$x) %>% 
ggplot(aes(y=PC2,x=PC1,color=pass))+
  geom_jitter()

Code
overall = scale(pc$x)[,1:2] %*% c(-0.8,0.2) 

dt %>% select(-id) %>% 
  mutate(overall = as.numeric(overall)) %>% 
  ggpairs(.,
          aes(color = ifelse(
            overall> quantile(overall,0.05),
            "pass","fail")),
          progress = F)

Code
dt  %>% 
  mutate(overall = overall,
         pass = overall>quantile(overall,0.05)) %>% 
  cbind(pc$x) %>% 
ggplot(aes(x=PC1,y=PC2,color=pass))+
  geom_jitter()